home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zbesi.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  4.2 KB  |  119 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((pi_ 3.141592653589793) (coner 1.0) (conei 0.0))
  12.   (declare (type double-float conei coner pi_))
  13.   (defun zbesi (zr zi fnu kode n cyr cyi nz ierr)
  14.     (declare (type double-float zr zi fnu)
  15.              (type (simple-array double-float (*)) cyr cyi)
  16.              (type f2cl-lib:integer4 kode n nz ierr))
  17.     (prog ((i 0) (inu 0) (k 0) (k1 0) (k2 0) (nn 0) (aa 0.0) (alim 0.0)
  18.            (arg 0.0) (csgni 0.0) (csgnr 0.0) (dig 0.0) (elim 0.0) (fnul 0.0)
  19.            (rl 0.0) (r1m5 0.0) (str 0.0) (tol 0.0) (zni 0.0) (znr 0.0) (az 0.0)
  20.            (bb 0.0) (fn 0.0) (ascle 0.0) (rtol 0.0) (atol 0.0) (sti 0.0))
  21.       (declare
  22.        (type double-float sti atol rtol ascle fn bb az znr zni tol str r1m5 rl
  23.         fnul elim dig csgnr csgni arg alim aa)
  24.        (type f2cl-lib:integer4 nn k2 k1 k inu i))
  25.       (setf ierr 0)
  26.       (setf nz 0)
  27.       (if (< fnu 0.0) (setf ierr 1))
  28.       (if (or (< kode 1) (> kode 2)) (setf ierr 1))
  29.       (if (< n 1) (setf ierr 1))
  30.       (if (/= ierr 0) (go end_label))
  31.       (setf tol (max (f2cl-lib:d1mach 4) 1.0e-18))
  32.       (setf k1 (f2cl-lib:i1mach 15))
  33.       (setf k2 (f2cl-lib:i1mach 16))
  34.       (setf r1m5 (f2cl-lib:d1mach 5))
  35.       (setf k (f2cl-lib:int (min (abs k1) (abs k2))))
  36.       (setf elim (* 2.303 (- (* k r1m5) 3.0)))
  37.       (setf k1 (f2cl-lib:int-sub (f2cl-lib:i1mach 14) 1))
  38.       (setf aa (* r1m5 k1))
  39.       (setf dig (min aa 18.0))
  40.       (setf aa (* aa 2.303))
  41.       (setf alim (+ elim (max (- aa) -41.45)))
  42.       (setf rl (+ (* 1.2 dig) 3.0))
  43.       (setf fnul (+ 10.0 (* 6.0 (- dig 3.0))))
  44.       (setf az (zabs zr zi))
  45.       (setf fn (+ fnu (f2cl-lib:int-sub n 1)))
  46.       (setf aa (/ 0.5 tol))
  47.       (setf bb (* (f2cl-lib:i1mach 9) 0.5))
  48.       (setf aa (min aa bb))
  49.       (if (> az aa) (go label260))
  50.       (if (> fn aa) (go label260))
  51.       (setf aa (f2cl-lib:fsqrt aa))
  52.       (if (> az aa) (setf ierr 3))
  53.       (if (> fn aa) (setf ierr 3))
  54.       (setf znr zr)
  55.       (setf zni zi)
  56.       (setf csgnr coner)
  57.       (setf csgni conei)
  58.       (if (>= zr 0.0) (go label40))
  59.       (setf znr (- zr))
  60.       (setf zni (- zi))
  61.       (setf inu (f2cl-lib:int fnu))
  62.       (setf arg (* (- fnu inu) pi_))
  63.       (if (< zi 0.0) (setf arg (- arg)))
  64.       (setf csgnr (cos arg))
  65.       (setf csgni (sin arg))
  66.       (if (= (mod inu 2) 0) (go label40))
  67.       (setf csgnr (- csgnr))
  68.       (setf csgni (- csgni))
  69.      label40
  70.       (multiple-value-bind
  71.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  72.            var-11 var-12)
  73.           (zbinu znr zni fnu kode n cyr cyi nz rl fnul tol elim alim)
  74.         (declare
  75.          (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 var-10
  76.           var-11 var-12))
  77.         (setf nz var-7))
  78.       (if (< nz 0) (go label120))
  79.       (if (>= zr 0.0) (go end_label))
  80.       (setf nn (f2cl-lib:int-sub n nz))
  81.       (if (= nn 0) (go end_label))
  82.       (setf rtol (/ 1.0 tol))
  83.       (setf ascle (* (f2cl-lib:d1mach 1) rtol 1000.0))
  84.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  85.                     ((> i nn) nil)
  86.         (tagbody
  87.           (setf aa (f2cl-lib:fref cyr (i) ((1 n))))
  88.           (setf bb (f2cl-lib:fref cyi (i) ((1 n))))
  89.           (setf atol 1.0)
  90.           (if (> (max (abs aa) (abs bb)) ascle) (go label55))
  91.           (setf aa (* aa rtol))
  92.           (setf bb (* bb rtol))
  93.           (setf atol tol)
  94.          label55
  95.           (setf str (- (* aa csgnr) (* bb csgni)))
  96.           (setf sti (+ (* aa csgni) (* bb csgnr)))
  97.           (f2cl-lib:fset (f2cl-lib:fref cyr (i) ((1 n))) (* str atol))
  98.           (f2cl-lib:fset (f2cl-lib:fref cyi (i) ((1 n))) (* sti atol))
  99.           (setf csgnr (- csgnr))
  100.           (setf csgni (- csgni))
  101.          label50))
  102.       (go end_label)
  103.      label120
  104.       (if (= nz -2) (go label130))
  105.       (setf nz 0)
  106.       (setf ierr 2)
  107.       (go end_label)
  108.      label130
  109.       (setf nz 0)
  110.       (setf ierr 5)
  111.       (go end_label)
  112.      label260
  113.       (setf nz 0)
  114.       (setf ierr 4)
  115.       (go end_label)
  116.      end_label
  117.       (return (values nil nil nil nil nil nil nil nz ierr)))))
  118.  
  119.